home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS01.ADF / ABasicStuff / Graphics / PaintBox.bas < prev    next >
BASIC Source File  |  1986-01-09  |  21KB  |  488 lines
  1.  
  2. 1000  'PAINTBOX - A simple drawing program.
  3. 1100  'Designed for the Amiga, V1.0, 512K, using ABasiC
  4. 1200  '   
  5. 1300  '  Check resolution of current screen, so we can restore it
  6. 1400  '  when we finish and invoke a new screen only if needed
  7. 1500  IF PIXEL(600,0)<0 THEN OLDRES%=320 ELSE OLDRES%=640
  8. 1600  '  Get resolution desired for this run
  9. 1700  GRAPHIC(0): RES%=0
  10. 1800  WHILE RES%=0
  11. 1900  PRINT "Select resolution (Hi/Lo) "
  12. 2000  INPUT C$: C$=LEFT$(C$,1)
  13. 2100  IF C$="H" OR C$="h" THEN RES%=640
  14. 2200  IF C$="L" OR C$="l" THEN RES%=320
  15. 2300  WEND
  16. 2400  CLR
  17. 2500  '  SAVBOX%   - Holds copy of selection area of screen, so it
  18. 2600  '              can be easily restored if window is resized
  19. 2700  '  OLDCOLOR% - Colors to restore to original screen
  20. 2800  '  COLORS%   - Program colors 3 thru 14 (for color cycling)
  21. 2900  '  PAT1%     - Used to define solid paint pattern
  22. 3000  '  PAT2%     - Used for "dotty" paint pattern (every other pixel)
  23. 3100  DIM SAVBOX%(1123),OLDCOLOR%(15),COLORS%(11),PAT1%(1),PAT2%(1)
  24. 3200  RES2%=RES%/320   'For hi-res aspect ratio for circles
  25. 3300  LIM%=RES%-17     'Right limit of useable window
  26. 3400  IF RES%<>OLDRES% THEN SCREEN RES%\640,4,0
  27. 3500  WINDOW #1,0,0,RES%,200,"PAINTBOX "
  28. 3600  ON ERROR GOTO 48400
  29. 3700  CMD #1: FONT 1: GRAPHIC(1): DRAWMODE 0: AUDIO 3,1
  30. 3800  TRUE=-1: FALSE=0   'For convenience
  31. 3900  '  Save current screen colors
  32. 4000  FOR I=0 TO 15
  33. 4100  ASK RGB I,X1%,X2%,X3%
  34. 4200  OLDCOLOR%(I)=(X1%*32+X2%)*32+X3%: NEXT
  35. 4300  '  Set colors for Paintbox
  36. 4400  RGB  0, 6, 6, 6    'Dark grey (background)
  37. 4500  RGB  1, 0, 0, 0    'Black
  38. 4600  RGB  2,10,10,10    'Light grey
  39. 4700  RGB  3,10, 0, 7    'Purple
  40. 4800  RGB  4,15, 8, 8    'Pink
  41. 4900  RGB  5,15, 0, 0    'Red
  42. 5000  RGB  6,15, 5, 0    'Orange
  43. 5100  RGB  7, 6, 2, 0    'Brown
  44. 5200  RGB  8,15,12, 0    'Yellow
  45. 5300  RGB  9, 6,12, 0    'Light green
  46. 5400  RGB 10, 0, 4, 0    'Dark green
  47. 5500  RGB 11, 0,10, 9    'Aqua
  48. 5600  RGB 12, 0, 0,12    'Blue
  49. 5700  RGB 13, 4, 6,15    'Light Blue
  50. 5800  RGB 14, 8, 0,12    'Violet
  51. 5900  RGB 15,15,15,15    'White (XOR of background color)
  52. 6000  FOR I=0 TO 11
  53. 6100  ASK RGB I+3,X1%,X2%,X3%
  54. 6200  COLORS%(I)=(X1%*32+X2%)*32+X3%: NEXT
  55. 6300  '  Make color selection boxes
  56. 6400  PENO 1
  57. 6500  FOR Y%=0 TO 120 STEP 10
  58. 6600  PENA Y%/10+3: BOX(0,Y%;20,Y%+10),1: NEXT
  59. 6700  PENA 1: BOX(21,110;45,120),1
  60. 6800  PENA 2: BOX(21,120;45,130),1
  61. 6900  '  Make style selection boxes
  62. 7000  FOR Y%=0 TO 100 STEP 10
  63. 7100  BOX(21,Y%;45,Y%+10): NEXT
  64. 7200  '  Show brush widths
  65. 7300  PENA 2: OUTLINE 0: DRAW(29,1 TO 37,9)
  66. 7400  AREA(26,11 TO 32,11 TO 40,19 TO 34,19)
  67. 7500  AREA(24,21 TO 34,21 TO 42,29 TO 32,29)
  68. 7600  AREA(22,31 TO 36,31 TO 44,39 TO 30,39)
  69. 7700  '  Moveable line
  70. 7800  DRAW(26,45 TO 39,45): DRAW(25,45),15: DRAW(40,45),15
  71. 7900  '  Lines radiating from a point
  72. 8000  AREA(26,52 TO 41,52 TO 36,57)
  73. 8100  DRAW(26,52),15: DRAW(41,52 TO 36,57),15
  74. 8200  '  Area color/pattern fill
  75. 8300  PENA 13: PENO 2: AREA(26,62 TO 43,63 TO 38,68 TO 26,68)
  76. 8400  '  Sizeable circle
  77. 8500  CIRCLE(33,75),4: DRAW(33,75),15
  78. 8600  '  Sizeable rectangle
  79. 8700  BOX(25,82;40,88): DRAW(25,82),15: DRAW(40,88),15
  80. 8800  '  Set/reset pattern
  81. 8900  PAT1%(0)=&HFFFF: PAT1%(1)=&HFFFF
  82. 9000  PAT2%(0)=&HAAAA: PAT2%(1)=&H5555
  83. 9100  PATTERN 2,PAT2%: DRAWMODE 1
  84. 9200  PENA 2: PENB 0: PENO 0: BOX(22,91;44,99),1
  85. 9300  PATTERN 2,PAT1%: DRAWMODE 0: DOTTY=FALSE
  86. 9400  '  Color cycle
  87. 9500  FOR COLOR=3 TO 13
  88. 9600  PENO COLOR: BOX(16+2*COLOR,101;17+2*COLOR,109): NEXT
  89. 9700  PENA 14: DRAW(44,101 TO 44,109)
  90. 9800  '  Action boxes
  91. 9900  PENA 1: PENO 1
  92. 10000 BOX(0,130;45,140): PRINT AT(3,138);"Erase"
  93. 10100 BOX(0,140;45,150): PRINT AT(3,148);"Clear"
  94. 10200 BOX(0,150;45,160): PRINT AT(7,158);"Save"
  95. 10300 BOX(0,160;45,170): PRINT AT(7,168);"Load"
  96. 10400 BOX(0,170;45,186): PRINT AT(7,181);"Exit"
  97. 10500 '  Initialize starting values
  98. 10600 W%=LIM%: H%=187
  99. 10700 COLOR=0: LASTCOLOR=0
  100. 10800 '  Save selection area
  101. 10900 SSHAPE(0,0;47,187),SAVBOX%
  102. 11000 '  Set background grey level
  103. 11100 ASK MOUSE X%,Y%,L%
  104. 11200 STYLE=-1: X%=120: SLIDE%=120: GOSUB 14300
  105. 11300 '
  106. 11400 '  Main loop - always return here or at next statement
  107. 11500 '
  108. 11600 WHILE L%>0: ASK MOUSE X%,Y%,L%: WEND
  109. 11700 ASK MOUSE X%,Y%,L%: Y%=Y%-1  'Fix Y% to align better with pointer
  110. 11800 GOSUB 17400   'See if window has been resized
  111. 11900 IF L%=0 OR X%<0 OR X%=46 OR X%>W% OR Y%<0 OR Y%>H% GOTO 11700
  112. 12000 IF STYLE<0 THEN GOSUB 14300: GOTO 11600
  113. 12100 IF X%<=45 GOTO 12700   'Make selection
  114. 12200 IF STYLE=0 GOTO 11600
  115. 12300 '  Paint in various widths
  116. 12400 IF STYLE <=4 THEN GOSUB 19200: GOTO 11700
  117. 12500 '  --------------Line  Lines Fill  Circle Box
  118. 12600 ON STYLE-4 GOSUB 20500,21800,22800,23500,24800: GOTO 11700
  119. 12700 IF Y%<130 GOTO 13200   'Color/style selection
  120. 12800 IF Y%<140 THEN GOSUB 25900: GOTO 11600    'Erase
  121. 12900 '  ---------------Clear Save  Load  Exit  Exit
  122. 13000 ON Y%\10-13 GOSUB 27000,28600,31300,39700,39700: GOTO 11700
  123. 13100 '  Select color
  124. 13200 IF X%<21 OR Y%>=110 THEN GOSUB 40800: GOTO 11600
  125. 13300 '  Select style
  126. 13400 IF Y%<90 THEN GOSUB 42800: GOTO 11600
  127. 13500 '  Set/reset pattern
  128. 13600 IF Y%<100 THEN GOSUB 43500: GOTO 11600
  129. 13700 '  Cycle colors
  130. 13800 GOSUB 44700: GOTO 11600
  131. 13900 '
  132. 14000 ' ----------------- Subroutines -----------------
  133. 14100 '
  134. 14200 '  Set grey level for background (in range 4-11)
  135. 14300 PENA 12: PENO 1: BOX(58,33;86,45),1  'OK box (blue)
  136. 14400 PENA 1: PRINT AT(65,42);"OK"
  137. 14500 PRINT AT(100,42);"Background grey level"
  138. 14600 PENA 0: PENO 1: BOX(58,50;281,62),1   'Box for slider
  139. 14700 PENA 5: PENO 5: BOX(60,52;SLIDE%+9,60),1  'Slider
  140. 14800 IF X%<58 OR X%>86 OR Y%<36 OR Y%>48 GOTO 15200   'Check OK box
  141. 14900 PENA 0: PENO 0: BOX(58,33;281,62),1  'Clean up the screen
  142. 15000 PENB 0: STYLE=0: RETURN   'All done
  143. 15100 '  Better check the EXIT box too, in case user wants to quit
  144. 15200 IF X%>=0 AND X%<46 AND X%<W% AND Y%>169 AND Y%<H% THEN GOSUB 39700
  145. 15300 '  If on end of slider, track with mouse, else move by steps
  146. 15400 IF X%<SLIDE% OR X%>SLIDE%+9 OR Y%<51 OR Y%>61 GOTO 16200
  147. 15500 X3%=X%-SLIDE%: X%=SLIDE%   'X3%=offset from end-9 of slider
  148. 15600 WHILE L%>0   'Move slider to follow mouse
  149. 15700 IF X%=SLIDE% OR X%<60 OR X%>270 GOTO 15900
  150. 15800 G1%=(X%+15)\30+2: GOSUB 16600
  151. 15900 ASK MOUSE X%,Y%,L%: X%=X%-X3%
  152. 16000 WEND
  153. 16100 RETURN
  154. 16200 G1%=(SLIDE%+15)\30+2   'Current background intensity
  155. 16300 IF X%<SLIDE% AND G1%>4 THEN G1%=G1%-1
  156. 16400 IF X%>SLIDE%+9 AND G1%<11 THEN G1%=G1%+1
  157. 16500 X%=(G1%-2)*30   'New location for slider
  158. 16600 IF X%>SLIDE% THEN PENA 5: PENO 5: BOX(SLIDE%+9,52;X%+9,60),1
  159. 16700 IF X%<SLIDE% THEN PENA 0: PENO 0: BOX(X%+10,52;SLIDE%+9,60),1
  160. 16800 SLIDE%=X%
  161. 16900 G2%=G1%\2 - 8*(G1%<8)   'G1%=background, G2%=the other grey 
  162. 17000 RGB 0,G1%,G1%,G1%: RGB 2,G2%,G2%,G2%
  163. 17100 RETURN
  164. 17200 '
  165. 17300 '  Restore selection area if window is resized
  166. 17400 ASK WINDOW WIDTH%,HEIGHT%: IF W%=WIDTH% AND H%=HEIGHT% THEN RETURN
  167. 17500 GSHAPE(0,0),SAVBOX%: PENO 15: IF COLOR=0 GOTO 18000
  168. 17600 '  Restore white borders/red print, etc. for items selected
  169. 17700 IF COLOR<3 THEN BOX(21,10*(COLOR+10);45,10*(COLOR+11))
  170. 17800 IF COLOR>2 THEN BOX(0,10*(COLOR-3);20,10*(COLOR-2))
  171. 17900 IF COLOR=15 THEN PENO 1: BOX(1,121;19,129): PENO 15
  172. 18000 IF STYLE>0 THEN BOX(21,10*(STYLE-1);45,10*STYLE)
  173. 18100 IF DOTTY THEN PENA COLOR: PENB LASTCOLOR: BOX(22,91;44,99),1
  174. 18200 PENA 5: PENB 0: PENO 5
  175. 18300 IF PENDING=1 THEN BOX(0,140;45,150)  'Clear
  176. 18400 IF PENDING=2 THEN BOX(0,170;45,186)  'Exit
  177. 18500 IF PENDING=3 THEN PRINT AT(7,158);"Save"
  178. 18600 IF PENDING=4 THEN PRINT AT(7,168);"Load"
  179. 18700 IF ERASING THEN PRINT AT(3,138);"Erase"
  180. 18800 PENA COLOR: PENB LASTCOLOR: PENO COLOR: W%=WIDTH%: H%=HEIGHT%
  181. 18900 RETURN
  182. 19000 '
  183. 19100 '  Various brush widths
  184. 19200 X1%=X%: Y1%=Y%: X3%=X1%-DX: IF X3%<47 THEN X3%=47
  185. 19300 OUTLINE 0   'Set to 1 for variable 2-color brush effect
  186. 19400 WHILE L%>0
  187. 19500 IF X%+DX<47 GOTO 19900   'Completely off screen
  188. 19600 X2%=X%-DX: IF X2%<47 THEN X2%=47   'Slightly off screen
  189. 19700 AREA(X3%,Y1%+DY TO X1%+DX,Y1%-DY TO X%+DX,Y%-DY TO X2%,Y%+DY)
  190. 19800 X1%=X%: X3%=X2%
  191. 19900 Y1%=Y%: ASK MOUSE X%,Y%,L%: Y%=Y%-1: WEND
  192. 20000 RETURN
  193. 20100 '
  194. 20200 '  Moveable line.  Each DRAW complements the current colors,
  195. 20300 '  so two DRAW's will restore the original.  The same process
  196. 20400 '  is used for circles and rectangles in other routines
  197. 20500 X1%=X%: Y1%=Y%: X2%=X%: Y2%=Y%
  198. 20600 DRAWMODE 2: DRAW(X1%,Y1%)
  199. 20700 WHILE L%>0
  200. 20800 IF X2%=X% AND Y2%=Y% GOTO 21100
  201. 20900 DRAW(X1%,Y1% TO X2%,Y2%): DRAW(X1%,Y1% TO X%,Y%)
  202. 21000 X2%=X%: Y2%=Y%
  203. 21100 ASK MOUSE X%,Y%,L%: Y%=Y%-1: IF X%<47 THEN X%=47
  204. 21200 WEND
  205. 21300 '  Finished - now reset DRAWMODE and draw the final line
  206. 21400 DRAWMODE ABS(DOTTY): DRAW(X1%,Y1% TO X2%,Y2%)
  207. 21500 RETURN
  208. 21600 '
  209. 21700 '  All lines from a point
  210. 21800 X1%=X%: Y1%=Y%
  211. 21900 WHILE L%>0
  212. 22000 DRAW(X1%,Y1% TO X%,Y%)
  213. 22100 ASK MOUSE X%,Y%,L%: Y%=Y%-1: IF X%<47 THEN X%=47
  214. 22200 WEND
  215. 22300 RETURN
  216. 22400 '
  217. 22500 '  Area color/pattern fill.  Will not fill over a previously
  218. 22600 '  pattern-filled area.  Line at X=46 keeps fill in working
  219. 22700 '  portion of screen and prevents bleeding into adjoining areas
  220. 22800 IF PIXEL(X%,Y%)=0 THEN DRAW(46,0 TO 46,187),2
  221. 22900 PAINT(X%,Y%),1: DRAW(46,0 TO 46,187),0
  222. 23000 WHILE L%>0: ASK MOUSE X%,Y%,L%: WEND
  223. 23100 RETURN
  224. 23200 '
  225. 23300 '  Variable sized circle.  RES2% handles the x-y aspect
  226. 23400 '  ration for high res screens
  227. 23500 X1%=X%: Y1%=Y%: X2%=X%: Y2%=Y%: R2%=0: DRAWMODE 2
  228. 23600 WHILE L%>0
  229. 23700 IF X%=X2% AND Y%=Y2% GOTO 24200
  230. 23800 R%=SQR(((X1%-X%)/RES2%)**2+(Y1%-Y%)**2)
  231. 23900 IF X1%-R%*RES2%<47 THEN R%=(X1%-47)/RES2%  'Left limit of circle
  232. 24000 CIRCLE(X1%,Y1%),R2%: CIRCLE(X1%,Y1%),R%
  233. 24100 X2%=X%: Y2%=Y%: R2%=R%
  234. 24200 ASK MOUSE X%,Y%,L%: Y%=Y%-1: IF X%<47 THEN X%=47
  235. 24300 WEND
  236. 24400 DRAWMODE ABS(DOTTY): CIRCLE(X1%,Y1%),R2%
  237. 24500 RETURN
  238. 24600 '
  239. 24700 '  Sizeable rectangle
  240. 24800 X1%=X%: Y1%=Y%: X2%=X%: Y2%=Y%: DRAWMODE 2
  241. 24900 WHILE L%>0
  242. 25000 IF X%=X2% AND Y%=Y2% GOTO 25300
  243. 25100 BOX(X1%,Y1%;X2%,Y2%): BOX(X1%,Y1%;X%,Y%)
  244. 25200 X2%=X%: Y2%=Y%
  245. 25300 ASK MOUSE X%,Y%,L%: Y%=Y%-1: IF X%<47 THEN X%=47
  246. 25400 WEND
  247. 25500 DRAWMODE ABS(DOTTY): BOX(X1%,Y1%;X2%,Y2%)
  248. 25600 RETURN
  249. 25700 '
  250. 25800 '  Erase
  251. 25900 ERASING=TRUE: IF DOTTY THEN GOSUB 43500  'Turn off pattern
  252. 26000 PENA 5: PRINT AT(3,138);"Erase"  'In red
  253. 26100 IF COLOR=0 GOTO 26600
  254. 26200 '  Remove white border around previously selected color
  255. 26300 PENO 1: IF COLOR<3 THEN BOX(21,10*(COLOR+10);45,10*(COLOR+11))
  256. 26400 IF COLOR>2 THEN BOX(0,10*(COLOR-3);20,10*(COLOR-2))
  257. 26500 IF COLOR=15 THEN PENO 15: BOX(1,121;19,129)
  258. 26600 COLOR=0: PENA 0: PENO 0
  259. 26700 RETURN
  260. 26800 '
  261. 26900 '  Clear - Insists on a second click (to avoid accidental clear)
  262. 27000 PENO 5: BOX(0,140;45,150): PENDING=1  'Window resize uses PENDING
  263. 27100 WHILE L%>0: ASK MOUSE X%,Y%,L%: WEND  'Wait for button release
  264. 27200 '  Wait for next click - GOSUB call checks for window resizing
  265. 27300 WHILE L%=0: ASK MOUSE X%,Y%,L%: GOSUB 17400: WEND
  266. 27400 PENO 1: BOX(0,140;45,150): PENDING=0: Y%=Y%-1
  267. 27500 '  Make sure the mouse is still in the CLEAR box
  268. 27600 IF X%<0 OR X%>45 OR X%>W% OR Y%<140 OR Y%>=150 OR Y%>H% GOTO 28000
  269. 27700 FOR X%=0 TO 93  'Add some pizazz to the clear
  270. 27800 PENO 15: BOX(47+X%,1+X%;LIM%-X%-1,186-X%)
  271. 27900 PENO 0: BOX(46+X%,X%;LIM%-X%,187-X%): NEXT
  272. 28000 W%=0: GOSUB 17400
  273. 28100 RETURN
  274. 28200 '
  275. 28300 '  Save screen to disk.  This, as well as LOAD, are a bit
  276. 28400 '  memory hungry.  Better not try resizing the window while
  277. 28500 '  this is going on, else GURU MEDITATION may result.
  278. 28600 IF RES%=320 THEN DIM A%(5985) ELSE DIM A%(13466)
  279. 28700 PENA 5: PENB 0: PRINT AT(7,158);"Save"
  280. 28800 SSHAPE(47,0;LIM%,187),A%  'Save active area in A%
  281. 28900 '  PENDING is used to restore screen if window is resized
  282. 29000 '  NOFILE is used in checking if the file already exists
  283. 29100 '  CANCEL is set if the user cancels the save operation
  284. 29200 '  OK=1 if the file already exists, =2 if OK to replace it
  285. 29300 PENDING=3: NOFILE=FALSE: CANCEL=FALSE: OK=0
  286. 29400 GOSUB 33500   'Get name desired for the file
  287. 29500 IF CANCEL GOTO 30600
  288. 29600 IF OK=2 GOTO 30400
  289. 29700 '  If file not found, gets "ON ERROR" and returns below
  290. 29800 OPEN "I",#2,NAME$: CLOSE #2
  291. 29900 PENA 5: PENB 5: PENO 1: BOX(75,69;183,91),1: PENA 1
  292. 30000 PRINT AT(78,78);"OK TO REPLACE": PRINT AT(78,88);"EXISTING FILE"
  293. 30100 OK=1: NOFILE=TRUE: GOSUB 35600: GOTO 29500
  294. 30200 '  No file, disk full or BSAVE I/O error returns here
  295. 30300 IF ERR=57 GOTO 30600   'Disk full or I/O error
  296. 30400 IF RES%=320 THEN I=23944 ELSE I=53868
  297. 30500 BSAVE NAME$,VARPTR(A%(0)),I  'Write disk file
  298. 30600 GSHAPE(47,0),A%: ERASE A%  'Restore screen
  299. 30700 PENA 1: PENB 0: PRINT AT(7,158);"Save"
  300. 30800 '  Play safe in case window resized while doing disk I/O
  301. 30900 PENDING=0: W%=0: GOSUB 17400  
  302. 31000 RETURN
  303. 31100 '
  304. 31200 '  Load disk file
  305. 31300 DIM A%(13466)  'Big enough for hi-res or lo-res file
  306. 31400 PENA 5: PENB 0: PRINT AT(7,168);"Load"
  307. 31500 SSHAPE(47,0;LIM%,187),A%
  308. 31600 PENDING=4: NOFILE=FALSE: CANCEL=FALSE: GOSUB 33500
  309. 31700 IF CANCEL GOTO 32600
  310. 31800 NOFILE=TRUE: BLOAD NAME$,VARPTR(A%(0)): GOTO 32600
  311. 31900 '  BLOAD error returns here
  312. 32000 IF ERR=57 GOTO 32600   'Disk I/O error
  313. 32100 PENA 5: PENB 5: PENO 5: BOX(79,75;179,85),1
  314. 32200 PENA 15: PRINT AT(82,83);"NO SUCH FILE"
  315. 32300 NOFILE=TRUE: GOSUB 35600: GOTO 31700
  316. 32400 '  If hi-res file on lo-res screen, only left half will show
  317. 32500 '  If lo-res file on hi-res screen, only half of screen is filled
  318. 32600 GSHAPE(47,0),A%: ERASE A%
  319. 32700 PENA 1: PENB 0: PRINT AT(7,168);"Load
  320. 32800 PENDING=0: W%=0: GOSUB 17400  'Just in case...
  321. 32900 RETURN
  322. 33000 '
  323. 33100 '  File name requestor routine.  We'll be looking for mouse
  324. 33200 '  clicks as well as character input, so use GET versus INPUT
  325. 33300 '  to receive the file name.  If the window is resized too 
  326. 33400 '  small to contain the CANCEL box, then cancel the operation.
  327. 33500 IF W%<240 THEN L%=SOUND(3,1,100,64,256): CANCEL=TRUE: RETURN
  328. 33600 PENB 2: PENO 2
  329. 33700 FOR I=0 TO 37  'Pop out the requestor box
  330. 33800 BOX(108-I,56-I;212+I,56+I): NEXT
  331. 33900 PENO 15: BOX(70,18;250,94)
  332. 34000 PENA 1: PRINT AT(100,35);"Enter file name"
  333. 34100 PENO 5: BOX(105,50;214,62)
  334. 34200 '  This little box is the "cursor", in yellow
  335. 34300 PENA 8: PENB 8: PENO 8: CURS=108: BOX(CURS,52;CURS+7,60),1
  336. 34400 PENA 12: PENB 12: PENO 1: BOX(186,74;239,86),1
  337. 34500 PENA 1: PRINT AT(189,83);"Cancel"
  338. 34600 '  Allowable file names (change it to suit your taste):
  339. 34700 '     First character must be a letter
  340. 34800 '     Remaining chars may be letters, numbers or . or -
  341. 34900 '     Maximum of 12 chars (plus "PAINT.", added by program)
  342. 35000 '     No two . or - may be adjoining
  343. 35100 '     May not end with . or -
  344. 35200 '     No embedded blanks allowed
  345. 35300 GET C$: IF C$<>"" GOTO 35300   'Clear any queued input
  346. 35400 NAME$="PAINT.": GOTO 35600  'Add the fixed prefix
  347. 35500 L%=SOUND(3,1,100,64,256)   'Beep if invalid entry
  348. 35600 GET C$: ASK MOUSE X%,Y%,L%: IF L%=0 GOTO 36500
  349. 35700 WHILE L%>0: ASK MOUSE X%,Y%,L%: WEND  'Wait for button release
  350. 35800 '  See if we're in the CANCEL box
  351. 35900 Y%=Y%-1  'For better pointer alignment   
  352. 36000 IF X%>185 AND X%<240 AND Y%>73 AND Y%<87 THEN CANCEL=TRUE: RETURN
  353. 36100 '  or perhaps the OK TO REPLACE box
  354. 36200 IF X%<75 OR X%>183 OR Y%<69 OR Y%>91 GOTO 36500
  355. 36300 IF OK<>1 THEN OK=0 ELSE OK=2: GOTO 36800
  356. 36400 '  Check window resizing - cancel if too small
  357. 36500 GOSUB 17400: IF W%<240 OR H%<87 THEN CANCEL=TRUE: RETURN
  358. 36600 IF C$="" GOTO 35600
  359. 36700 IF NOT NOFILE GOTO 37000  'Else clear the last warning message
  360. 36800 PENA 2: PENB 2: PENO 2: BOX(75,69;183,91),1
  361. 36900 NOFILE=FALSE: IF OK<>2 THEN OK=0 ELSE RETURN
  362. 37000 IF LEN(NAME$)<7 GOTO 38300  'This must be the first character
  363. 37100 IF ASC(C$)<>13 GOTO 37400   '13=Carriage return
  364. 37200 IF RIGHT$(NAME$,1)<>"." AND RIGHT$(NAME$,1)<>"-" THEN RETURN
  365. 37300 GOTO 35500  'Trailing . or - not allowed
  366. 37400 IF ASC(C$)<>8 GOTO 37900   '8=Backspace
  367. 37500 NAME$=LEFT$(NAME$,LEN(NAME$)-1)  'Shorten name
  368. 37600 PENA 2: PENB 2: PENO 2: BOX(CURS,52;CURS+7,60),1  'Back up cursor
  369. 37700 PENA 8: PENB 8: PENO 8: CURS=CURS-8: BOX(CURS,52;CURS+7,60),1
  370. 37800 GOTO 35600
  371. 37900 IF C$<>"." AND C$<>"-" GOTO 38500
  372. 38000 IF LEN(NAME$)>=17 GOTO 35500  'Ending . or - not allowed
  373. 38100 IF RIGHT$(NAME$,1)="." OR RIGHT$(NAME$,1)="-" GOTO 35500
  374. 38200 GOTO 38700
  375. 38300 IF ASC(C$)=8 GOTO 35600   'Superfluous backspace
  376. 38400 IF C$<"A" GOTO 35500  'Test used only for first character
  377. 38500 IF C$<"0" OR (C$>"9" AND C$<"A") GOTO 35500
  378. 38600 IF (C$>"Z" AND C$<"a") OR C$>"z" GOTO 35500
  379. 38700 IF LEN(NAME$)>=18 GOTO 35500
  380. 38800 '  Add this letter and advance cursor
  381. 38900 NAME$=NAME$+C$
  382. 39000 PENA 2: PENB 2: PENO 2: BOX(CURS,52;CURS+7,60),1
  383. 39100 PENA 1: PRINT AT(CURS,59);C$
  384. 39200 PENA 8: PENB 8: PENO 8: CURS=CURS+8: BOX(CURS,52;CURS+7,60),1
  385. 39300 GOTO 35600  'Get another character
  386. 39400 RETURN
  387. 39500 '
  388. 39600 '  Exit - Requires second click (to avoid accidental exit)
  389. 39700 PENO 5: BOX(0,170;45,186): PENDING=2
  390. 39800 WHILE L%>0: ASK MOUSE X%,Y%,L%: WEND
  391. 39900 WHILE L%=0: ASK MOUSE X%,Y%,L%: GOSUB 17400: WEND
  392. 40000 '  Be sure he's still in the EXIT box
  393. 40100 Y%=Y%-1   'As usual
  394. 40200 IF X%>=0 AND X%<46 AND X%<W% AND Y%>169 AND Y%<H% GOTO 48800
  395. 40300 '  Decided not to exit after all
  396. 40400 PENO 1: BOX(0,170;45,186): PENO COLOR: PENDING=0
  397. 40500 RETURN
  398. 40600 '
  399. 40700 '  Set color
  400. 40800 IF ERASING THEN PENA 1: PRINT AT(3,138);"Erase"  'Reset to black
  401. 40900 ERASING=FALSE: IF COLOR=0 GOTO 41400
  402. 41000 '  Delete while highlight around previous color
  403. 41100 PENO 1: IF COLOR<3 THEN BOX(21,10*(COLOR+10);45,10*(COLOR+11))
  404. 41200 IF COLOR>2 THEN BOX(0,10*(COLOR-3);20,10*(COLOR-2))
  405. 41300 IF COLOR=15 THEN PENO 15: BOX(1,121;19,129)
  406. 41400 I=COLOR: COLOR=Y%\10+3: IF X%>21 THEN COLOR=COLOR-13
  407. 41500 '  The previous color becomes the PENB color (for pattern)
  408. 41600 IF I<>COLOR THEN LASTCOLOR=I: PENB I
  409. 41700 '  Add white highlight around the new color
  410. 41800 PENO 15: IF COLOR<3 THEN BOX(21,10*(COLOR+10);45,10*(COLOR+11))
  411. 41900 IF COLOR>2 THEN BOX(0,10*(COLOR-3);20,10*(COLOR-2))
  412. 42000 '  Fix up the pattern box to show the current 2 colors
  413. 42100 PENA COLOR: IF DOTTY THEN BOX(22,91;44,99),1
  414. 42200 '  Add an extra black highlight when color white is selected
  415. 42300 IF COLOR=15 THEN PENO 1: BOX(1,121;19,129)
  416. 42400 PENO COLOR
  417. 42500 RETURN
  418. 42600 '
  419. 42700 '  Set style (and brush width, adjusted for resolution)
  420. 42800 PENO 1: IF STYLE>0 THEN BOX(21,10*(STYLE-1);45,10*STYLE)
  421. 42900 STYLE=Y%\10+1
  422. 43000 PENO 15: BOX(21,10*(STYLE-1);45,10*STYLE)
  423. 43100 PENA COLOR: PENO COLOR: DY=STYLE-1: DX=2*DY*RES2%
  424. 43200 RETURN
  425. 43300 '
  426. 43400 '  Set/reset pattern.  When pattern is in use, DOTTY=TRUE
  427. 43500 IF DOTTY GOTO 43900
  428. 43600 DOTTY=TRUE: PATTERN 2,PAT2%: DRAWMODE 1
  429. 43700 PENB 0: PENO 15: LASTCOLOR=0: BOX(22,91;44,99),1
  430. 43800 GOTO 44100
  431. 43900 PENA 2: PENB 0: PENO 0: LASTCOLOR=0: BOX(22,91;44,99),1
  432. 44000 DOTTY=FALSE: PATTERN 2,PAT1%: DRAWMODE 0
  433. 44100 PENA COLOR: PENO COLOR
  434. 44200 RETURN
  435. 44300 '
  436. 44400 '  Cycle colors (except black, white and greys).  Suppress color
  437. 44500 '  boxes, etc. until done.  This option can give the effect of
  438. 44600 '  movement (as may be noted in the selection box itself)
  439. 44700 PENA 2: OUTLINE 0
  440. 44800 IF NOT DOTTY GOTO 45100
  441. 44900 PATTERN 2,PAT1%: DRAWMODE 0
  442. 45000 AREA(23,92 TO 43,92 TO 43,98 TO 23,98)
  443. 45100 FOR I=0 TO 120 STEP 10
  444. 45200 AREA(1,I+1 TO 19,I+1 TO 19,I+9 TO 1,I+9): NEXT
  445. 45300 PENA 0: PENO 2: OUTLINE 1
  446. 45400 AREA(26,62 TO 43,63 TO 38,68 TO 26,68)
  447. 45500 IF ERASING THEN PENA 1: PRINT AT(3,138);"Erase"
  448. 45600 X2%=W%: Y2%=H%
  449. 45700 WHILE L%>0: ASK MOUSE X%,Y%,L%: WEND  'Wait for button release
  450. 45800 '  Stop on the next click within the window
  451. 45900 WHILE L%=0 OR X%<0 OR X%>W% OR Y%<0 OR Y%>H%
  452. 46000 FOR I=0 TO 11: X%=COLORS%(I)
  453. 46100 RGB (X1%+I)MOD 12+3,X%\1024,(X%\32) MOD 32,X% MOD 32: NEXT
  454. 46200 X1%=X1%+1: ASK MOUSE X%,Y%,L%: Y%=Y%-1
  455. 46300 '  Check for window resizing.  If so turn off color boxes again
  456. 46400 GOSUB 17400: IF X2%<>W% OR Y2%<>H% GOTO 44700
  457. 46500 WEND
  458. 46600 '  We're done.  Restore color boxes, etc.
  459. 46700 FOR I=0 TO 11: X%=COLORS%(I)
  460. 46800 RGB I+3,X%\1024,(X%\32)MOD 32,X% MOD 32: NEXT
  461. 46900 OUTLINE 0
  462. 47000 FOR I=0 TO 120 STEP 10
  463. 47100 PENA I/10+3: AREA(1,I+1 TO 19,I+1 TO 19,I+9 TO 1,I+9): NEXT
  464. 47200 IF COLOR=15 THEN PENO 1: BOX(1,121;19,129)
  465. 47300 OUTLINE 1: PENA 13: PENO 2: AREA(26,62 TO 43,63 TO 38,68 TO 26,68)
  466. 47400 IF ERASING THEN PENA 5: PRINT AT(3,138);"Erase"
  467. 47500 PENA COLOR: PENO COLOR
  468. 47600 IF NOT DOTTY THEN RETURN
  469. 47700 PATTERN 2,PAT2%: DRAWMODE 1
  470. 47800 OUTLINE 0: AREA(23,92 TO 43,92 TO 43,98 TO 23,98)
  471. 47900 RETURN
  472. 48000 '
  473. 48100 '  Error recovery (for disk I/O and file present errors)
  474. 48200 '  ERR 53 = No file, ERR 57 = Disk full or I/O error
  475. 48300 '  If anything else, abort the run and report the error
  476. 48400 IF ERR<>53 AND ERR<>57 GOTO 48800
  477. 48500 IF NOFILE THEN RESUME 32000 ELSE RESUME 30300
  478. 48600 '
  479. 48700 '  Restore original screen and colors
  480. 48800 FOR I=0 TO 15: X%=OLDCOLOR%(I)
  481. 48900 RGB I,X%\1024,(X%\32)MOD 32,X% MOD 32: NEXT
  482. 49000 CLR: CLOSE #1
  483. 49100 IF RES%<>OLDRES% THEN SCREEN OLDRES%\640,4,0
  484. 49200 GRAPHIC(0)
  485. 49300 '  Report any unexpected error
  486. 49400 IF ERR<>0 AND ERR<>53 AND ERR<>57 THEN PRINT ERR$(ERR);ERL
  487. 49500 END
  488.